{-# LANGUAGE PolyKinds    #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Orphan instances for external types/classes.

module Pos.Util.Orphans
       (
       -- * Instances
       -- ** Lift Byte
       -- ** Lift HashMap
       -- ** FromJSON Byte, ToJSON Byte
       -- ** Hashable Byte
       -- ** HasLoggerName (MonadPseudoRandom drg)

       -- ** Hashable
       -- *** Millisecond, Microsecond

       -- ** NFData
       -- *** Millisecond, Microsecond

       -- ** MonadRandom
       -- *** monad transformers
       -- *** Gen (from QuickCheck)

       -- ** Buildable
       -- *** "Data.Time.Units" types
       -- *** @()@
       ) where

import           Universum

import           Control.Monad.Except (MonadError)
import           Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..),
                     unliftIO, withUnliftIO)
import           Control.Monad.Trans.Identity (IdentityT (..))
import           Control.Monad.Trans.Lift.Local (LiftLocal (..))
import           Control.Monad.Trans.Resource (MonadResource (..), ResourceT,
                     transResourceT)
import qualified Crypto.Random as Rand
import           Data.Aeson (FromJSON (..), ToJSON (..))
import           Data.Hashable (Hashable (hashWithSalt))
import qualified Data.HashMap.Strict as HM
import           Data.Tagged (Tagged (Tagged))
import           Data.Time.Units (Attosecond, Day, Femtosecond, Fortnight, Hour,
                     Microsecond, Millisecond, Minute, Nanosecond, Picosecond,
                     Second, Week, toMicroseconds)
import           Data.Typeable (typeRep)
import qualified Ether
import qualified Formatting as F
import           Formatting.Buildable (build)
import qualified Language.Haskell.TH.Syntax as TH
import           Serokell.Data.Memory.Units (Byte, fromBytes, toBytes)
import qualified Text.JSON.Canonical as Canonical
import           Text.JSON.Canonical.Types (Int54 (..))

import           Pos.Util.Json.Canonical (SchemaError)
import           Pos.Util.Wlog (CanLog, HasLoggerName (..), LoggerNameBox (..))

----------------------------------------------------------------------------
-- Orphan miscellaneous instances
----------------------------------------------------------------------------

instance (TH.Lift k, TH.Lift v) => TH.Lift (HashMap k v) where
    lift x = let l = HM.toList x in [|HM.fromList l|]

instance Hashable Byte where
    hashWithSalt i = hashWithSalt i . toInteger

instance TH.Lift Byte where
    lift x = let b = toBytes x in [|fromBytes b :: Byte|]

instance FromJSON Byte where
    parseJSON = fmap fromBytes . parseJSON

instance ToJSON Byte where
    toJSON = toJSON . toBytes

instance Monad m => Canonical.ToJSON m Natural where
    toJSON x = Canonical.toJSON (Int54 $ fromIntegral x)

instance MonadError SchemaError m => Canonical.FromJSON m Natural where
    fromJSON = \case
        (Canonical.JSNum num) ->
            pure . fromIntegral $ int54ToInt64 num
        other ->
            Canonical.expected "An attribute size restriction number" (Just (show other))

instance Rand.DRG drg => HasLoggerName (Rand.MonadPseudoRandom drg) where
    askLoggerName = pure "MonadPseudoRandom"
    modifyLoggerName = flip const

instance {-# OVERLAPPABLE #-}
         (MonadTrans t, Functor (t m), Monad (t m), Rand.MonadRandom m)
         => Rand.MonadRandom (t m) where
    getRandomBytes = lift . Rand.getRandomBytes

----------------------------------------------------------------------------
-- Hashable
----------------------------------------------------------------------------

instance Hashable Millisecond where
    hashWithSalt i a = hashWithSalt i (toInteger a)

instance Hashable Microsecond where
    hashWithSalt i a = hashWithSalt i (toInteger a)

----------------------------------------------------------------------------
-- NFData
----------------------------------------------------------------------------

instance NFData Millisecond where
    rnf ms = rnf (toInteger ms)

instance NFData Microsecond where
    rnf ms = rnf (toInteger ms)

----------------------------------------------------------------------------
-- Orphan Buildable instances
----------------------------------------------------------------------------

instance Buildable Attosecond  where build = build @String . show
instance Buildable Femtosecond where build = build @String . show
instance Buildable Picosecond  where build = build @String . show
instance Buildable Nanosecond  where build = build @String . show
instance Buildable Millisecond where build = build @String . show
instance Buildable Second      where build = build @String . show
instance Buildable Minute      where build = build @String . show
instance Buildable Hour        where build = build @String . show
instance Buildable Day         where build = build @String . show
instance Buildable Week        where build = build @String . show
instance Buildable Fortnight   where build = build @String . show

-- | Special case. We don't want to print greek letter mu in console because
-- it breaks things sometimes.
instance Buildable Microsecond where
    build = build . (++ "mcs") . show . toMicroseconds

-- | This orphan instance is sometimes useful and why not have it?
instance Buildable () where
    build _ = "()"

instance (Typeable s, Buildable a) => Buildable (Tagged s a) where
    build tt@(Tagged v) = F.bprint ("Tagged " F.% F.shown F.% " " F.% F.build) ts v
      where
        ts = typeRep proxy
        proxy = (const Proxy :: Tagged s a -> Proxy s) tt

----------------------------------------------------------------------------
-- MonadResource/ResourceT
----------------------------------------------------------------------------

instance {-# OVERLAPPABLE #-}
    (MonadResource m, MonadTrans t, MonadIO (t m)) =>
        MonadResource (t m)
  where
    liftResourceT = lift . liftResourceT

instance CanLog m => CanLog (ResourceT m)
instance (Monad m, HasLoggerName m) => HasLoggerName (ResourceT m) where
    askLoggerName = lift askLoggerName
    modifyLoggerName = transResourceT . modifyLoggerName

----------------------------------------------------------------------------
-- Instances required by 'ether'
----------------------------------------------------------------------------

instance
    (Monad m, MonadTrans t, Monad (t m), CanLog m) =>
        CanLog (Ether.TaggedTrans tag t m)

instance (Monad m, CanLog m) => CanLog (IdentityT m)

instance
    (LiftLocal t, Monad m, HasLoggerName m) =>
        HasLoggerName (Ether.TaggedTrans tag t m)
  where
    askLoggerName = lift askLoggerName
    modifyLoggerName = liftLocal askLoggerName modifyLoggerName

instance
    (Monad m, HasLoggerName m) => HasLoggerName (IdentityT m)
  where
    askLoggerName = lift askLoggerName
    modifyLoggerName = liftLocal askLoggerName modifyLoggerName

deriving instance LiftLocal LoggerNameBox

instance MonadUnliftIO (t m) => MonadUnliftIO (Ether.TaggedTrans tag t m) where
    {-# INLINE askUnliftIO #-}
    askUnliftIO =
        Ether.TaggedTrans $
        withUnliftIO $ \u ->
        return (UnliftIO (unliftIO u . \case Ether.TaggedTrans trans -> trans))
    {-# INLINE withRunInIO #-}
    withRunInIO inner =
        Ether.TaggedTrans $
        withRunInIO $ \run ->
        inner (run . \case Ether.TaggedTrans trans -> trans)
